home *** CD-ROM | disk | FTP | other *** search
/ Stone Design / Stone Design.iso / Stone_Friends / Wave / WavesWorld / Source / Libraries / tcl7.4b3 / library / init.tcl next >
Encoding:
Text File  |  1994-12-17  |  7.3 KB  |  263 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # @(#) init.tcl 1.35 94/12/17 16:22:04
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. set auto_path [info library]
  16.  
  17. # unknown:
  18. # Invoked when a Tcl command is invoked that doesn't exist in the
  19. # interpreter:
  20. #
  21. #    1. See if the autoload facility can locate the command in a
  22. #       Tcl script file.  If so, load it and execute it.
  23. #    2. If the command was invoked interactively at top-level:
  24. #        (a) see if the command exists as an executable UNIX program.
  25. #        If so, "exec" the command.
  26. #        (b) see if the command requests csh-like history substitution
  27. #        in one of the common forms !!, !<number>, or ^old^new.  If
  28. #        so, emulate csh's history substitution.
  29. #        (c) see if the command is a unique abbreviation for another
  30. #        command.  If so, invoke the command.
  31.  
  32. proc unknown args {
  33.     global auto_noexec auto_noload env unknown_pending tcl_interactive
  34.     global errorCode errorInfo
  35.  
  36.     set name [lindex $args 0]
  37.     if ![info exists auto_noload] {
  38.     #
  39.     # Make sure we're not trying to load the same proc twice.
  40.     #
  41.     if [info exists unknown_pending($name)] {
  42.         unset unknown_pending($name)
  43.         if {[array size unknown_pending] == 0} {
  44.         unset unknown_pending
  45.         }
  46.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  47.     }
  48.     set unknown_pending($name) pending;
  49.     set ret [catch {auto_load $name} msg]
  50.     unset unknown_pending($name);
  51.     if {$ret != 0} {
  52.         return -code $ret "error while autoloading \"$name\": $msg"
  53.     }
  54.     if ![array size unknown_pending] {
  55.         unset unknown_pending
  56.     }
  57.     if $msg {
  58.         set code [catch {uplevel $args} msg]
  59.         if {$code ==  1} {
  60.         #
  61.         # Strip the last five lines off the error stack (they're
  62.         # from the "uplevel" command).
  63.         #
  64.  
  65.         set new [split $errorInfo \n]
  66.         set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
  67.         return -code error -errorcode $errorCode \
  68.             -errorinfo $new $msg
  69.         } else {
  70.         return -code $code $msg
  71.         }
  72.     }
  73.     }
  74.     if {([info level] == 1) && ([info script] == "") && $tcl_interactive} {
  75.     if ![info exists auto_noexec] {
  76.         if [auto_execok $name] {
  77.         return [uplevel exec >&@stdout <@stdin $args]
  78.         }
  79.     }
  80.     if {$name == "!!"} {
  81.         return [uplevel {history redo}]
  82.     }
  83.     if [regexp {^!(.+)$} $name dummy event] {
  84.         return [uplevel [list history redo $event]]
  85.     }
  86.     if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  87.         return [uplevel [list history substitute $old $new]]
  88.     }
  89.     set cmds [info commands $name*]
  90.     if {[llength $cmds] == 1} {
  91.         return [uplevel [lreplace $args 0 0 $cmds]]
  92.     }
  93.     if {[llength $cmds] != 0} {
  94.         if {$name == ""} {
  95.         return -code error "empty command name \"\""
  96.         } else {
  97.         return -code error \
  98.             "ambiguous command name \"$name\": [lsort $cmds]"
  99.         }
  100.     }
  101.     }
  102.     return -code error "invalid command name \"$name\""
  103. }
  104.  
  105. # auto_load:
  106. # Checks a collection of library directories to see if a procedure
  107. # is defined in one of them.  If so, it sources the appropriate
  108. # library file to create the procedure.  Returns 1 if it successfully
  109. # loaded the procedure, 0 otherwise.
  110.  
  111. proc auto_load cmd {
  112.     global auto_index auto_oldpath auto_path env errorInfo errorCode
  113.  
  114.     if [info exists auto_index($cmd)] {
  115.     uplevel #0 $auto_index($cmd)
  116.     return [expr {[info commands $cmd] != ""}]
  117.     }
  118.     if [catch {set path $auto_path}] {
  119.     if [catch {set path $env(TCLLIBPATH)}] {
  120.         if [catch {set path [info library]}] {
  121.         return 0
  122.         }
  123.     }
  124.     }
  125.     if [info exists auto_oldpath] {
  126.     if {$auto_oldpath == $path} {
  127.         return 0
  128.     }
  129.     }
  130.     set auto_oldpath $path
  131.     catch {unset auto_index}
  132.     for {set i [expr [llength $path] - 1]} {$i >= 0} {incr i -1} {
  133.     set dir [lindex $path $i]
  134.     set f ""
  135.     if [catch {set f [open $dir/tclIndex]}] {
  136.         continue
  137.     }
  138.     set error [catch {
  139.         set id [gets $f]
  140.         if {$id == "# Tcl autoload index file, version 2.0"} {
  141.         eval [read $f]
  142.         } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
  143.         while {[gets $f line] >= 0} {
  144.             if {([string index $line 0] == "#")
  145.                 || ([llength $line] != 2)} {
  146.             continue
  147.             }
  148.             set name [lindex $line 0]
  149.             set auto_index($name) "source $dir/[lindex $line 1]"
  150.         }
  151.         } else {
  152.         error "$dir/tclIndex isn't a proper Tcl index file"
  153.         }
  154.     } msg]
  155.     if {$f != ""} {
  156.         close $f
  157.     }
  158.     if $error {
  159.         error $msg $errorInfo $errorCode
  160.     }
  161.     }
  162.     if [info exists auto_index($cmd)] {
  163.     uplevel #0 $auto_index($cmd)
  164.     if {[info commands $cmd] != ""} {
  165.         return 1
  166.     }
  167.     }
  168.     return 0
  169. }
  170.  
  171. # auto_execok:
  172. # Returns 1 if there's an executable in the current path for the
  173. # given name, 0 otherwise.  Builds an associative array auto_execs
  174. # that caches information about previous checks, for speed.
  175.  
  176. proc auto_execok name {
  177.     global auto_execs env
  178.  
  179.     if [info exists auto_execs($name)] {
  180.     return $auto_execs($name)
  181.     }
  182.     set auto_execs($name) 0
  183.     if {[string first / $name] >= 0} {
  184.     if {[file executable $name] && ![file isdirectory $name]} {
  185.         set auto_execs($name) 1
  186.     }
  187.     return $auto_execs($name)
  188.     }
  189.     foreach dir [split $env(PATH) :] {
  190.     if {$dir == ""} {
  191.         set dir .
  192.     }
  193.     if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
  194.         set auto_execs($name) 1
  195.         return 1
  196.     }
  197.     }
  198.     return 0
  199. }
  200.  
  201. # auto_reset:
  202. # Destroy all cached information for auto-loading and auto-execution,
  203. # so that the information gets recomputed the next time it's needed.
  204. # Also delete any procedures that are listed in the auto-load index
  205. # except those related to auto-loading.
  206.  
  207. proc auto_reset {} {
  208.     global auto_execs auto_index auto_oldpath
  209.     foreach p [info procs] {
  210.     if {[info exists auto_index($p)] && ($p != "unknown")
  211.         && ![string match auto_* $p]} {
  212.         rename $p {}
  213.     }
  214.     }
  215.     catch {unset auto_execs}
  216.     catch {unset auto_index}
  217.     catch {unset auto_oldpath}
  218. }
  219.  
  220. # auto_mkindex:
  221. # Regenerate a tclIndex file from Tcl source files.  Takes as argument
  222. # the name of the directory in which the tclIndex file is to be placed,
  223. # floowed by any number of glob patterns to use in that directory to
  224. # locate all of the relevant files.
  225.  
  226. proc auto_mkindex {dir args} {
  227.     global errorCode errorInfo
  228.     set oldDir [pwd]
  229.     cd $dir
  230.     set dir [pwd]
  231.     append index "# Tcl autoload index file, version 2.0\n"
  232.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  233.     append index "# and sourced to set up indexing information for one or\n"
  234.     append index "# more commands.  Typically each line is a command that\n"
  235.     append index "# sets an element in the auto_index array, where the\n"
  236.     append index "# element name is the name of a command and the value is\n"
  237.     append index "# a script that loads the command.\n\n"
  238.     foreach file [eval glob $args] {
  239.     set f ""
  240.     set error [catch {
  241.         set f [open $file]
  242.         while {[gets $f line] >= 0} {
  243.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  244.             append index "set [list auto_index($procName)]"
  245.             append index " \"source \$dir/$file\"\n"
  246.         }
  247.         }
  248.         close $f
  249.     } msg]
  250.     if $error {
  251.         set code $errorCode
  252.         set info $errorInfo
  253.         catch {close $f}
  254.         cd $oldDir
  255.         error $msg $info $code
  256.     }
  257.     }
  258.     set f [open tclIndex w]
  259.     puts $f $index nonewline
  260.     close $f
  261.     cd $oldDir
  262. }
  263.